Shareware Grab Bag

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / qbcalc.arc / CALC.ASC next >

Wrap

Text File | 1987-02-15 | 13.9 KB | 360 lines

' TSR (Memory Resident) 4 Function Calculator ' by Kauko J. Laurinolli 404-981-9550 ' Feb. 15, 1987 ' Be my quest, use, modify, improve and mutilate this Freebie code the way you wish ' No Guarantee of any kind provided ' STAYRES and MACH2 Copyrighted by Micro-Help ' Sample Compiled with Qbasic V2.01, works also with V1.01 or V2.00 ' Linked with MS-Link V3.06 ' bascom calc.asc/o; ' link stayres+calc/e+gwcom,,nul,bcom20+mhlib ' Program uses EMS memory if available ' Activate with Alt X ' Use H to get help after program is activated with Alt X ' This program uses couple of great programmers utilities: '╔═════════════════════════════════════════════════════════════════════╗ '║ Stay-Res Program Package to Make Basic Program Resident and ║ '║ Mach 2 Program Package to Speed-Up Basic ║ '║ Both programs are available from Micro-Help, Inc ║ '║ Phone No: 404-973-9272 or 1-800-922-3383 ║ '╚═════════════════════════════════════════════════════════════════════╝ defint a-z dim res$(25),oper$(25),format$(5),round(5) common shared dtaseg,nor,hi,rev,stack$ scr.buffer$ = space$(4050) 'reserve memory key off: cls: result#= 0: stack$="" start.col=52: new.col= 1: des=2: ind$="Right": ind2$="Left ": top.row =23: active= 0 format$(0)="+#,###,###,###,###": round(0)= 0 format$(1)="+###,###,###,###.#": round(1)= 1 format$(2)="+##,###,###,###.##": round(2)= 2 format$(3)="+#,###,###,###.###": round(3)= 3 format$(4)="+,###,###,###.####": round(4)= 4 call get.monitor (last.monitor,nor,hi,rev,curs.normal,curs.insert,start.line,end.line) kshift = varptr(scr.buffer$) 'get segment address call hotkey( 3,kscan,kshift,ecode) 'allocate string space dtaseg=kshift if ecode <> 0 then print "hotkey 3 ";ecode kscan = 4000 call hotkey( 4,kscan,kshift,ecode) 'set storage segment if ecode <> 0 then print "hotkey 4 ";ecode call mhmt16(dtaseg,box) 'call for space call mhwind(stack$, 0,dtaseg, 0, 0, 0, 0, 0, 0, 2,box*16,ecode) 'initialize storage if ecode <> 0 then print "mhwind ";ecode '-------------------------- PRINT OPENING SCREEN ---------------------- cls call mhscr( 0,"╔══════════════════════╗", 1, 1,nor) call mhscr( 0,"║ Resident Calculator ║", 2, 1,nor) call mhscr( 0,"║ by Micro-Help ║", 3, 1, 7) call mhscr( 0,"║ and K.J. Laurinolli ║", 4, 1,nor) call mhscr( 0,"║ Version 1.01 ║", 5, 1,nor) call mhscr( 0,"║ Activate with Alt X ║", 6, 1,nor) call mhscr( 0,"╚══════════════════════╝", 7, 1,nor) hot.oper= 0 locate 8,1,1,start.line,end.line 'cursor location '----------------------- TERMINATE AND STAY RESIDENT ------------------ HOT.KEY: kscan=&h2D: kshift=8: ecode= 0 '&h2D = Alt X call hotkey(hot.oper,kscan,kshift,ecode) 'TSR, HOT-KEY = Alt X if ecode <> 0 then print "hotkey 0 ";ecode call get.monitor (monitor,nor,hi,rev,curs.normal,curs.insert,start.line,end.line) if last.monitor <> monitor then _ call mhvideo(monitor): last.monitor=monitor 'change monitor if (kscan=2 and monitor=&hB800) or _ (kscan=3 and monitor=&hB800) or _ (kscan=7 and monitor=&hB000) then goto NO.CHANGE call hotkey( 2, 3,kshift,ecode) 'change video mode if ecode <> 0 then print "hotkey 2 ";ecode NO.CHANGE: call mhwind(stack$, 0,dtaseg, 1, 0, 1, 1,25,80, 1, 0,ecode) 'save whole screen to buffer 1 color 0,7: gosub MESSAGE: goto PRINT.OLD '---------------------------- GET INPUT ------------------------------- GET.INPUT: in.string$="": active= -1 CLR.KEY: while inkey$ <> "": wend 'clear keyboard buffer def seg=0 GET.KEY: n$=inkey$ poke &h417,(peek(&h417) or &h20) 'set num lock on if n$ = "" then goto GET.KEY 'get key def seg call mhucase(n$) 'upcase input if (asc(n$) < 58 and _ 'get numbers asc(n$) > 47 or _ asc(n$) = 46) then goto CLEAR.ENTRY _ else goto NO.NUMBER CLEAR.ENTRY: call mhscr( 0,space$(29),24,start.col,rev) 'clear entry field if len(in.string$)=10 then gosub SOUND.OUT: _ call mhscr( 0,in.string$,24,start.col+28-len(in.string$),rev): _ goto CLR.KEY data.in= 1: in.string$=in.string$+n$: _ 'print input call mhscr( 0,in.string$+" ",24,start.col+28-(len(in.string$)),rev): _ goto CLR.KEY NO.NUMBER: if (n$="+") or (n$="-") or (n$="*") or (n$="/") _ 'get operator then _ if data.in=1 then goto CALC _ else _ gosub SOUND.OUT: goto CLR.KEY if n$="D" then des=des+1: gosub MESSAGE: _ 'change decimal if des > 4 then des=0: goto PRINT.NEW _ else goto PRINT.NEW if n$="T" then _ 'move tape swap start.col,new.col: swap ind$,ind2$: _ call mhwind(stack$, 0,dtaseg, 2, 0, 1, 1,25,80, 1, 0,ecode): _ 'restore screen from buffer 1 gosub MESSAGE: goto PRINT.OLD if n$="Q" then if len(in.string$) > 0 then _ 'clear entry field call mhscr( 0,space$(29),24,start.col,rev): _ goto GET.INPUT if n$="Z" then in.string$="0": goto SET.LENGTH 'clear result '--- remove REM from the next 3 lines to make X to release memory REM if n$="X" then hot.oper= 9: _ 'release memory if X entered REM def seg=0: poke &h417,(peek(&h417) and &hDF): def seg: _ REM goto HOT.KEY if n$=chr$(27) then _ 'exit def seg=0: poke &h417,(peek(&h417) and &hDF): def seg: _ call mhwind(stack$, 0,dtaseg, 2, 0, 1, 1,25,80, 1, 0,ecode): _ 'restore whole screen from buffer 1 goto HOT.KEY 'hide again if n$="H" then call HELP: goto CLR.KEY 'call help if n$=chr$(8) then _ 'backspace if len(in.string$) > 0 then gosub BACKSPACE: goto CLR.KEY else gosub SOUND.OUT: goto CLR.KEY gosub SOUND.OUT: goto CLR.KEY '*************************** BACKSPACE ******************************** BACKSPACE: in.string$=left$(in.string$,len(in.string$)-1): res$(24)=in.string$ call mhscr( 0,space$(29),24,start.col,rev) 'clear entry field call mhscr( 0,in.string$,24,start.col+28-len(in.string$),rev) return '****************************** CALC ********************************** CALC: data.in=0 if val(in.string$)=0 and n$="/" then gosub SOUND.OUT: goto CALC.DONE if n$="+" then result#=result#+val(in.string$): goto CALC.DONE if n$="-" then result#=result#-val(in.string$): goto CALC.DONE if n$="*" then result#=result#*val(in.string$): goto CALC.DONE if n$="/" then result#=result#/val(in.string$): goto CALC.DONE CALC.DONE: un.round$=in.string$ 'round input gosub ROUND.INPUT SET.LENGTH: if des > 0 then number$=left$(number$,instr(number$,chr$(0))-1) 'strip trailing chr$(0) if n$<>"Z" then res$(24)=number$+" "+n$+"= " else _ 'store last input+operator res$(24)=number$+" CL ": result#=0 if len(res$(24)) < 20 then res$(24)=space$(20-len(res$(24)))+res$(24) for row=1 to 23 'move all up 1 line res$(row)=res$(row+1) next PRINT.OLD: for row=23 to 1 step -1 'print old results + operator if res$(row) = "" then row=1: goto OLD.DONE top.row=row call mhscr( 0,space$( 9)+res$(row),row,start.col,rev) OLD.DONE: next PRINT.NEW: 'print result call mhscr( 0,space$(29),24,start.col,rev) 'clear entry field un.round$=str$(result#) gosub ROUND.INPUT call mhpusing(stack$, 0,24,start.col+6,rev,32,ecode,number$,format$(des)) if ecode<>0 then locate 5,1: print "Ecode=";ecode goto GET.INPUT '************************** ROUND INPUT ******************************* ROUND.INPUT: if des > 0 then _ number$=space$(20): lset number$=" "+un.round$+chr$(0): _ call mhround(stack$,number$,round(des)) _ else _ number$=" "+str$(fix(val(un.round$)+.5)) return 'round.input '*************************** MESSAGE ********************************** MESSAGE: if not active then _ call mhscr( 0,space$(20)+"0.00"+space$(5),24,start.col,rev) 'print first 0 call mhscr( 0," « Tape= "+ind$+" » « Dec="+str$(round(des))+" » ",25,start.col,rev) 'message return 'message '**************************** SOUND *********************************** SOUND.OUT: out &h43,182: out &h42,&h33: out &h42,5 ' sound effects by Micro-Help n=inp(&h61): n1=n: n=n or 3: out &h61,n for a!=1 to 500: next out &h42,&h33: out &h42,6 for a!=1 to 500: next out &h61,n1 return 'sound.out '************************ GET MONITOR TYPE **************************** defint a-z SUB GET.MONITOR(MONITOR,NOR,HI,REV,CURS.NORMAL,CURS.INSERT,START.LINE,END.LINE) STATIC def seg=0 if (peek(&h410) and &h30)=&h30 then _ nor= 7: hi=15: rev=112: curs.normal=3085: curs.insert=1293: _ start.line=12: end.line=13: _ monitor=&hB000: _ '&hB000 for mono color nor,0,0 _ else _ nor=30: hi=31: rev= 79: curs.normal=1543: curs.insert=1031: _ start.line= 6: end.line= 7: _ monitor=&hB800: _ '&hB800 for color &hFFFF for no snow-check color 7,0,0 def seg call mhvideo(monitor) end sub 'get.monitor mono / color '******************************* HELP ********************************* SUB HELP STATIC call mhwind(stack$,hi,dtaseg, 1, 0, 3,20,19,63, 2, 2,ecode) 'save window to buffer 3 if ecode <> 0 then print " Help Error 1 ="; ecode for x= 4 to 18 'clear window call mhscr( 0,space$(42), x,21,nor) next call mhscr( 0," TSR Calculator by K. Laurinolli", 4,22,hi) call mhscr( 0," 404-981-9550", 5,22,hi) call mhscr( 0," VALID KEYS:", 6,22,hi) call mhscr( 0,"0 - 9 Use Only Cursor Pad Keys", 8,22,hi) call mhscr( 0,"+, -, * and / to Calculate", 9,22,hi) call mhscr( 0,"H Help", 10,22,hi) call mhscr( 0,"Z Zero Result", 11,22,hi) call mhscr( 0,"D Move Decimal Point", 12,22,hi) call mhscr( 0,"Q Clear Entry", 13,22,hi) call mhscr( 0,"T Move Tape between Left and Right", 14,22,hi) call mhscr( 0,"── Delete Last Character of Entry", 15,22,hi) call mhscr( 0,"<Esc> Return to Previous Application", 16,22,hi) call mhscr( 0," Press Any key to Continue", 18,22,hi) AGAIN: b$=inkey$: if b$="" then goto AGAIN while inkey$ <> "": wend 'clear keyboard buffer call mhwind(stack$, 0,dtaseg, 2, 0, 3,20,19,63, 2, 0,ecode) 'restore help window from buffer 3 if ecode <> 0 then print " Help Error 2 ="; ecode end sub 'help ''' 3 ╔══════════════════════════════════════════╗ ''' 4 ║ TSR Calculator by K. Laurinolli ║ ''' 5 ║ 404-981-9550 ║ ''' 6 ║ VALID KEYS: ║ ''' 7 ║ ║ ''' 8 ║ Cursor Pad Keys 0 - 9 ║ ''' 9 ║ +, -, * and / to Calculate ║ ''' 10 ║ H Help ║ ''' 11 ║ Z Zero Result ║ ''' 12 ║ D Change Decimal Point ║ ''' 13 ║ Q Clear Entry ║ ''' 14 ║ T to move Tape between Left and Right║ ''' 15 ║ ── Delete Last Character of Entry ║ ''' 16 ║ <Esc> Return to Previous Application ║ ''' 17 ║ ║ ''' 18 ║ Press Any key to Continue ║ ''' 19 ╚══════════════════════════════════════════╝